unit ceParser;

interface

uses ceGlobal, ceConsts;

type
  TzParser = class
  private
    fLines: TzLines;
    fInput: widestring;
    procedure Parser(p: PzElement);
    procedure ParseIt;
    procedure SetInput(const Value: widestring);
  public
    property Input: widestring read fInput write SetInput;
    property Output: TzLines read fLines write fLines;
  published
  end;

implementation

{ TzParser }

procedure TzParser.Parser(p: PzElement);
begin
  p^.Bold := false;
  p^.Color := clWhite;
  if not Assigned(fParser) then Exit;
  fParser.Parse(p);
end;

procedure TzParser.ParseIt;
var
  t: widestring;
  i: longword;
  check: boolean;
  comment_open: boolean;
  comment_start: string;
  string_open: boolean;

  function isNewline(s: string): boolean;
  begin
    Result := s = NEWLINE;
  end;

  function isSpace(s: string): boolean;
  begin
    Result := false;
    if string_open then Exit;
    Result := s = SPACE;
  end;

  function isOperator(s: string): boolean;
  begin
    Result := false;
    if string_open then Exit;
    Result := s[1] in ['.', ',', ';', ':', '(', ')', '[', ']', '<', '>', '=', '+', '-', '*', '/', '^'];
  end;

  function isOperator2(s: string): boolean;
  begin
    Result := false;
    if string_open then Exit;
    Result := (s = ':=') or (s = '<>');
  end;

  function isCommentStart(s: string): boolean;
  begin
    Result := false;
    if string_open then Exit;
    Result := (s = '{') or (s = '//') or (s = '(*');
    if Result then
      comment_start := s;
  end;

  function isCommentEnd(s: string): boolean;
  begin
    Result := false;
    if string_open then Exit;

    if comment_start = '//' then
      Result := s = #13
    else if comment_start = '{' then
      Result := (s = '}')
    else
      Result := (s = '*)');
  end;

  function Check1: boolean;
  begin
    Result := (not isNewLine(fText[i]))
      and (not isSpace(fText[i]))
      and (i <= Length(fText))
      and (not isCommentStart(fText[i]))
      and (not isCommentStart(fText[i] + fText[i + 1]))
      and (not isOperator2(fText[i] + fText[i + 1]))
      and (not isOperator(fText[i]));
  end;

  function Check2: boolean;
  begin
    Result := (not isNewline(fText[i])) and (not isCommentEnd(fText[i])) and (not isCommentend(fText[i] + fText[i + 1]));
  end;

var
  p: PzElement;
  ti: integer;
begin
  i := 1;
  fText := Value;
  txt_height := 0;
  fLines.Clear;
  comment_open := false;
  string_open := false;
  if Length(fText) = 0 then Exit;
  while (i <= Length(fText)) or ((i = 1) and (Length(fText) = 1)) do
  begin
    t := '';

    if comment_open then
      check := Check2
    else
      check := Check1;

    if i = Length(fText) then
    begin
      t := t + fText[i];
      inc(i);
    end else
      while check do
      begin
        if (fText[i] = '''') then
          string_open := not string_open;

        t := t + fText[i];
        inc(i);
        if comment_open then
          check := Check2
        else
          check := Check1;
      end;

    if (t <> '') then
    begin
      New(p);
      p^.Value := t;

      if comment_open then
      begin
        p^.Typ := ceComment;
        Parser(p);
      end else
      begin
        if TryStrToInt(t, ti) then
          p^.Typ := ceInteger
        else if ((t[1] = '''') and (t[Length(t)] = '''')) or (t[1] = '#') then
          p^.Typ := ceString
        else if (t = 'true') or (t = 'false') or (t = 'nil') then
          p^.Typ := ceInteger
        else
          p^.Typ := ceNormal;
      end;
      Parser(p);
      fLines.Add(p);
      t := '';
    end;

    if isCommentStart(fText[i]) then
    begin
      comment_open := true;
      New(p);
      p^.Value := fText[i];
      p^.Typ := ceComment;
      Parser(p);
      fLines.Add(p);
      inc(i);
    end
    else if isCommentStart(fText[i] + fText[i + 1]) then
    begin
      comment_open := true;
      New(p);
      p^.Value := fText[i] + fText[i + 1];
      p^.Typ := ceComment;
      Parser(p);
      fLines.Add(p);
      inc(i, 2);
    end
    else if isCommentEnd(fText[i]) or isCommentEnd(fText[i] + fText[i + 1]) then
    begin
      comment_open := false;
      if (comment_start = '{') then
      begin
        New(p);
        p^.Value := fText[i];
        p^.Typ := ceComment;
        Parser(p);
        fLines.Add(p);
        inc(i);
      end
      else if (comment_start = '(*') then
      begin
        New(p);
        p^.Value := fText[i] + fText[i + 1];
        p^.Typ := ceComment;
        fLines.Add(p);
        Parser(p);
        inc(i, 2);
      end else
        inc(i, 2);
      if comment_start = '//' then
      begin
        New(p);
        p^.Value := NEWLINE;
        p^.Typ := ceNormal;
        Parser(p);
        fLines.Add(p);
      end;
    end
    else if isNewLine(fText[i]) then
    begin
      New(p);
      p^.Value := NEWLINE;
      fLines.Add(p);
      inc(i);
      if fText[i] = #10 then
        inc(i);
    end
    else if isOperator2(fText[i] + fText[i + 1]) then
    begin
      New(p);
      p^.Value := fText[i] + fText[i + 1];
      p^.Typ := ceOperator;
      Parser(p);
      fLines.Add(p);
      inc(i, 2);
    end else if isOperator(fText[i]) then
    begin
      New(p);
      p^.Value := fText[i];
      p^.Typ := ceOperator;
      Parser(p);
      fLines.Add(p);
      inc(i);
    end else if isSpace(fText[i]) then
    begin
      New(p);
      p^.Value := SPACE;
      Parser(p);
      fLines.Add(p);
      inc(i);
    end;
  end;
  txt_height := 0;
end;

procedure TzParser.SetInput(const Value: widestring);
begin
  fInput := Value;
end;

end.

